home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / site / LWP / Protocol.pm < prev    next >
Encoding:
Perl POD Document  |  1999-12-28  |  7.9 KB  |  296 lines
  1.  
  2. package LWP::Protocol;
  3.  
  4. =head1 NAME
  5.  
  6. LWP::Protocol - Base class for LWP protocols
  7.  
  8. =head1 SYNOPSIS
  9.  
  10.  package LWP::Protocol::foo;
  11.  require LWP::Protocol;
  12.  @ISA=qw(LWP::Protocol);
  13.  
  14. =head1 DESCRIPTION
  15.  
  16. This class is used a the base class for all protocol implementations
  17. supported by the LWP library.
  18.  
  19. When creating an instance of this class using
  20. C<LWP::Protocol::create($url)>, and you get an initialised subclass
  21. appropriate for that access method. In other words, the
  22. LWP::Protocol::create() function calls the constructor for one of its
  23. subclasses.
  24.  
  25. All derived LWP::Protocol classes need to override the request()
  26. method which is used to service a request. The overridden method can
  27. make use of the collect() function to collect together chunks of data
  28. as it is received.
  29.  
  30. =head1 SEE ALSO
  31.  
  32. Inspect the F<LWP/Protocol/file.pm> and F<LWP/Protocol/http.pm> files
  33. for examples of usage.
  34.  
  35. =head1 METHODS AND FUNCTIONS
  36.  
  37. =cut
  38.  
  39.  
  40. require LWP::MemberMixin;
  41. @ISA = qw(LWP::MemberMixin);
  42.  
  43. use strict;
  44. use Carp ();
  45. use HTTP::Status 'RC_INTERNAL_SERVER_ERROR';
  46. require HTML::HeadParser;
  47.  
  48. my %ImplementedBy = (); # scheme => classname
  49.  
  50.  
  51. =head2 $prot = new HTTP::Protocol;
  52.  
  53. The LWP::Protocol constructor is inherited by subclasses. As this is a
  54. virtual base class this method should B<not> be called directly.
  55.  
  56. =cut
  57.  
  58. sub new
  59. {
  60.     my($class) = @_;
  61.  
  62.     my $self = bless {
  63.     'timeout' => 0,
  64.     'use_alarm' => 1,
  65.     'parse_head' => 1,
  66.     }, $class;
  67.     $self;
  68. }
  69.  
  70.  
  71. =head2 $prot = LWP::Protocol::create($url)
  72.  
  73. Create an object of the class implementing the protocol to handle the
  74. given scheme. This is a function, not a method. It is more an object
  75. factory than a constructor. This is the function user agents should
  76. use to access protocols.
  77.  
  78. =cut
  79.  
  80. sub create
  81. {
  82.     my $scheme = shift;
  83.     my $impclass = LWP::Protocol::implementor($scheme) or
  84.     Carp::croak("Protocol scheme '$scheme' is not supported");
  85.  
  86.     return $impclass->new($scheme);
  87. }
  88.  
  89.  
  90. =head2 $class = LWP::Protocol::implementor($scheme, [$class])
  91.  
  92. Get and/or set implementor class for a scheme.  Returns '' if the
  93. specified scheme is not supported.
  94.  
  95. =cut
  96.  
  97. sub implementor
  98. {
  99.     my($scheme, $impclass) = @_;
  100.  
  101.     if ($impclass) {
  102.     $ImplementedBy{$scheme} = $impclass;
  103.     }
  104.     my $ic = $ImplementedBy{$scheme};
  105.     return $ic if $ic;
  106.  
  107.     return '' unless $scheme =~ /^([.+\-\w]+)$/;  # check valid URL schemes
  108.     $scheme = $1; # untaint
  109.     $scheme =~ s/[.+\-]/_/g;  # make it a legal module name
  110.  
  111.     $ic = "LWP::Protocol::$scheme";  # default location
  112.     $ic = "LWP::Protocol::nntp" if $scheme eq 'news'; #XXX ugly hack
  113.     no strict 'refs';
  114.     unless (defined @{"${ic}::ISA"}) {
  115.     eval "require $ic";
  116.     if ($@) {
  117.         if ($@ =~ /^Can't locate/) { #' #emacs get confused by '
  118.         $ic = '';
  119.         } else {
  120.         die "$@\n";
  121.         }
  122.     }
  123.     }
  124.     $ImplementedBy{$scheme} = $ic if $ic;
  125.     $ic;
  126. }
  127.  
  128.  
  129. =head2 $prot->request(...)
  130.  
  131.  $response = $protocol->request($request, $proxy, undef);
  132.  $response = $protocol->request($request, $proxy, '/tmp/sss');
  133.  $response = $protocol->request($request, $proxy, \&callback, 1024);
  134.  
  135. Dispactches a request over the protocol, and returns a response
  136. object. This method needs to be overridden in subclasses.  Referer to
  137. L<LWP::UserAgent> for description of the arguments.
  138.  
  139. =cut
  140.  
  141. sub request
  142. {
  143.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  144.     Carp::croak('LWP::Protocol::request() needs to be overridden in subclasses');
  145. }
  146.  
  147.  
  148. =head2 $prot->timeout($seconds)
  149.  
  150. Get and set the timeout value in seconds
  151.  
  152.  
  153. =head2 $prot->use_alarm($yesno)
  154.  
  155. Indicates if the library is allowed to use the core alarm()
  156. function to implement timeouts.
  157.  
  158. =head2 $prot->parse_head($yesno)
  159.  
  160. Should we initialize response headers from the <head> section of HTML
  161. documents.
  162.  
  163. =cut
  164.  
  165. sub timeout    { shift->_elem('timeout',    @_); }
  166. sub use_alarm  { shift->_elem('use_alarm',  @_); }
  167. sub parse_head { shift->_elem('parse_head', @_); }
  168. sub max_size   { shift->_elem('max_size',   @_); }
  169.  
  170.  
  171. =head2 $prot->collect($arg, $response, $collector)
  172.  
  173. Called to collect the content of a request, and process it
  174. appropriately into a scalar, file, or by calling a callback.  If $arg
  175. is undefined, then the content is stored within the $response.  If
  176. $arg is a simple scalar, then $arg is interpreted as a file name and
  177. the content is written to this file.  If $arg is a reference to a
  178. routine, then content is passed to this routine.
  179.  
  180. The $collector is a routine that will be called and which is
  181. reponsible for returning pieces (as ref to scalar) of the content to
  182. process.  The $collector signals EOF by returning a reference to an
  183. empty sting.
  184.  
  185. The return value from collect() is the $response object reference.
  186.  
  187. B<Note:> We will only use the callback or file argument if
  188. $response->is_success().  This avoids sendig content data for
  189. redirects and authentization responses to the callback which would be
  190. confusing.
  191.  
  192. =cut
  193.  
  194. sub collect
  195. {
  196.     my ($self, $arg, $response, $collector) = @_;
  197.     my $content;
  198.     my($use_alarm, $parse_head, $timeout, $max_size) =
  199.       @{$self}{qw(use_alarm parse_head timeout max_size)};
  200.  
  201.     my $parser;
  202.     if ($parse_head && $response->content_type eq 'text/html') {
  203.     $parser = HTML::HeadParser->new($response->{'_headers'});
  204.     }
  205.     my $content_size = 0;
  206.  
  207.     if (!defined($arg) || !$response->is_success) {
  208.     while ($content = &$collector, length $$content) {
  209.         if ($parser) {
  210.         $parser->parse($$content) or undef($parser);
  211.         }
  212.         alarm(0) if $use_alarm;
  213.         LWP::Debug::debug("read " . length($$content) . " bytes");
  214.         $response->add_content($$content);
  215.         $content_size += length($$content);
  216.         if ($max_size && $content_size > $max_size) {
  217.         LWP::Debug::debug("Aborting because size limit exceeded");
  218.         my $tot = $response->header("Content-Length") || 0;
  219.         $response->header("X-Content-Range", "bytes 0-$content_size/$tot");
  220.         last;
  221.         }
  222.         alarm($timeout) if $use_alarm;
  223.     }
  224.     }
  225.     elsif (!ref($arg)) {
  226.     open(OUT, ">$arg") or
  227.         return new HTTP::Response RC_INTERNAL_SERVER_ERROR,
  228.               "Cannot write to '$arg': $!";
  229.         binmode(OUT);
  230.         local($\) = ""; # ensure standard $OUTPUT_RECORD_SEPARATOR
  231.     while ($content = &$collector, length $$content) {
  232.         if ($parser) {
  233.         $parser->parse($$content) or undef($parser);
  234.         }
  235.         alarm(0) if $use_alarm;
  236.         LWP::Debug::debug("read " . length($$content) . " bytes");
  237.         print OUT $$content;
  238.         $content_size += length($$content);
  239.         if ($max_size && $content_size > $max_size) {
  240.         LWP::Debug::debug("Aborting because size limit exceeded");
  241.         my $tot = $response->header("Content-Length") || 0;
  242.         $response->header("X-Content-Range", "bytes 0-$content_size/$tot");
  243.         last;
  244.         }
  245.         alarm($timeout) if $use_alarm;
  246.     }
  247.     close(OUT);
  248.     }
  249.     elsif (ref($arg) eq 'CODE') {
  250.     while ($content = &$collector, length $$content) {
  251.         if ($parser) {
  252.         $parser->parse($$content) or undef($parser);
  253.         }
  254.         alarm(0) if $use_alarm;
  255.         LWP::Debug::debug("read " . length($$content) . " bytes");
  256.             eval {
  257.         &$arg($$content, $response, $self);
  258.         };
  259.         if ($@) {
  260.             chomp($@);
  261.         $response->header('X-Died' => $@);
  262.         last;
  263.         }
  264.         alarm($timeout) if $use_alarm
  265.     }
  266.     }
  267.     else {
  268.     return new HTTP::Response RC_INTERNAL_SERVER_ERROR,
  269.                   "Unexpected collect argument  '$arg'";
  270.     }
  271.     $response;
  272. }
  273.  
  274.  
  275. =head2 $prot->collect_once($arg, $response, $content)
  276.  
  277. Can be called when the whole response content is available as
  278. $content.  This will invoke collect() with a collector callback that
  279. returns a reference to $content the first time and an empty string the
  280. next.
  281.  
  282. =cut
  283.  
  284. sub collect_once
  285. {
  286.     my($self, $arg, $response) = @_;
  287.     my $content = \ $_[3];
  288.     my $first = 1;
  289.     $self->collect($arg, $response, sub {
  290.     return $content if $first--;
  291.     return \ "";
  292.     });
  293. }
  294.  
  295. 1;
  296.